home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / fish / 001-100 / 001-025 / 018 / xlisp1.6 / xlisp.h < prev    next >
C/C++ Source or Header  |  1995-03-17  |  9KB  |  321 lines
  1. /* xlisp - a small subset of lisp */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. /* system specific definitions */
  7. #define AZTEC_SM
  8.  
  9. #include <stdio.h>
  10. #include <ctype.h>
  11. #ifndef MEGAMAX
  12. #include <setjmp.h>
  13. #endif
  14.  
  15. /* NNODES    number of nodes to allocate in each request (1000) */
  16. /* TDEPTH    trace stack depth (500) */
  17. /* EDEPTH    evaluation stack depth (1000) */
  18. /* FORWARD    type of a forward declaration () */
  19. /* LOCAL    type of a local function (static) */
  20. /* AFMT        printf format for addresses ("%x") */
  21. /* FIXNUM    data type for fixed point numbers (long) */
  22. /* ITYPE    fixed point input conversion routine type (long atol()) */
  23. /* ICNV        fixed point input conversion routine (atol) */
  24. /* IFMT        printf format for fixed point numbers ("%ld") */
  25. /* FLONUM    data type for floating point numbers (float) */
  26. /* SYSTEM    enable the control-d command */
  27.  
  28. /* absolute value macros */
  29. #ifndef abs
  30. #define abs(n)    ((n) < 0 ? -(n) : (n))
  31. #endif
  32. #ifndef fabs
  33. #define fabs(n)    ((n) < 0.0 ? -(n) : (n))
  34. #endif
  35.  
  36. /* for the MegaMax compiler */
  37. #ifdef MEGAMAX
  38. #define LOCAL
  39. #define AFMT        "%lx"
  40. #endif
  41.  
  42. /* for the AZTEC C compiler - small model */
  43. #ifdef AZTEC_SM
  44. #define SYSTEM
  45. #define NIL        0
  46. #endif
  47.  
  48. /* for the AZTEC C compiler - large model */
  49. #ifdef AZTEC_LM
  50. #define FLONUM        double
  51. #define SYSTEM
  52. #define NIL        0L
  53. #endif
  54.  
  55. /* default important definitions */
  56. #ifndef NNODES
  57. #define NNODES        1000
  58. #endif
  59. #ifndef TDEPTH
  60. #define TDEPTH        500
  61. #endif
  62. #ifndef EDEPTH
  63. #define EDEPTH        1000
  64. #endif
  65. #ifndef FORWARD
  66. #define FORWARD
  67. #endif
  68. #ifndef LOCAL
  69. #define LOCAL        static
  70. #endif
  71. #ifndef AFMT
  72. #define AFMT        "%x"
  73. #endif
  74. #ifndef FIXNUM
  75. #define FIXNUM        long
  76. #endif
  77. #ifndef ITYPE
  78. #define ITYPE        long atol()
  79. #endif
  80. #ifndef ICNV
  81. #define ICNV(n)        atol(n)
  82. #endif
  83. #ifndef IFMT
  84. #define IFMT        "%ld"
  85. #endif
  86. #ifndef FLONUM
  87. #define FLONUM        float
  88. #endif
  89.  
  90. /* useful definitions */
  91. #define TRUE    1
  92. #define FALSE    0
  93. #ifndef NIL
  94. #define NIL    (NODE *)0
  95. #endif
  96.  
  97. /* program limits */
  98. #define STRMAX        100        /* maximum length of a string constant */
  99. #define HSIZE        199        /* symbol hash table size */
  100. #define SAMPLE        100        /* control character sample rate */
  101.     
  102. /* node types */
  103. #define FREE    0
  104. #define SUBR    1
  105. #define FSUBR    2
  106. #define LIST    3
  107. #define SYM    4
  108. #define INT    5
  109. #define STR    6
  110. #define OBJ    7
  111. #define FPTR    8
  112. #define FLOAT    9
  113. #define VECT    10
  114.  
  115. /* node flags */
  116. #define MARK    1
  117. #define LEFT    2
  118.  
  119. /* string types */
  120. #define DYNAMIC    0
  121. #define STATIC    1
  122.  
  123. /* new node access macros */
  124. #define ntype(x)    ((x)->n_type)
  125.  
  126. /* type predicates */
  127. #define atom(x)        ((x) == NIL || (x)->n_type != LIST)
  128. #define null(x)        ((x) == NIL)
  129. #define listp(x)    ((x) == NIL || (x)->n_type == LIST)
  130. #define consp(x)    ((x) && (x)->n_type == LIST)
  131. #define subrp(x)    ((x) && (x)->n_type == SUBR)
  132. #define fsubrp(x)    ((x) && (x)->n_type == FSUBR)
  133. #define stringp(x)    ((x) && (x)->n_type == STR)
  134. #define symbolp(x)    ((x) && (x)->n_type == SYM)
  135. #define filep(x)    ((x) && (x)->n_type == FPTR)
  136. #define objectp(x)    ((x) && (x)->n_type == OBJ)
  137. #define fixp(x)        ((x) && (x)->n_type == INT)
  138. #define floatp(x)    ((x) && (x)->n_type == FLOAT)
  139. #define vectorp(x)    ((x) && (x)->n_type == VECT)
  140.  
  141. /* cons access macros */
  142. #define car(x)        ((x)->n_car)
  143. #define cdr(x)        ((x)->n_cdr)
  144. #define rplaca(x,y)    ((x)->n_car = (y))
  145. #define rplacd(x,y)    ((x)->n_cdr = (y))
  146.  
  147. /* symbol access macros */
  148. #define getvalue(x)    ((x)->n_symvalue)
  149. #define setvalue(x,v)    ((x)->n_symvalue = (v))
  150. #define getplist(x)    ((x)->n_symplist->n_cdr)
  151. #define setplist(x,v)    ((x)->n_symplist->n_cdr = (v))
  152. #define getpname(x)    ((x)->n_symplist->n_car)
  153.  
  154. /* vector access macros */
  155. #define getsize(x)    ((x)->n_vsize)
  156. #define getelement(x,i)    ((x)->n_vdata[i])
  157. #define setelement(x,i,v) ((x)->n_vdata[i] = (v))
  158.  
  159. /* object access macros */
  160. #define getclass(x)    ((x)->n_vdata[0])
  161. #define getivar(x,i)    ((x)->n_vdata[i+1])
  162. #define setivar(x,i,v)    ((x)->n_vdata[i+1] = (v))
  163.  
  164. /* subr/fsubr access macros */
  165. #define getsubr(x)    ((x)->n_subr)
  166.  
  167. /* fixnum/flonum access macros */
  168. #define getfixnum(x)    ((x)->n_int)
  169. #define getflonum(x)    ((x)->n_float)
  170.  
  171. /* string access macros */
  172. #define getstring(x)    ((x)->n_str)
  173. #define setstring(x,v)    ((x)->n_str = (v))
  174.  
  175. /* file access macros */
  176. #define getfile(x)    ((x)->n_fp)
  177. #define setfile(x,v)    ((x)->n_fp = (v))
  178. #define getsavech(x)    ((x)->n_savech)
  179. #define setsavech(x,v)    ((x)->n_savech = (v))
  180.  
  181. /* symbol node */
  182. #define n_symplist    n_info.n_xsym.xsy_plist
  183. #define n_symvalue    n_info.n_xsym.xsy_value
  184.  
  185. /* subr/fsubr node */
  186. #define n_subr        n_info.n_xsubr.xsu_subr
  187.  
  188. /* list node */
  189. #define n_car        n_info.n_xlist.xl_car
  190. #define n_cdr        n_info.n_xlist.xl_cdr
  191.  
  192. /* integer node */
  193. #define n_int        n_info.n_xint.xi_int
  194.  
  195. /* float node */
  196. #define n_float        n_info.n_xfloat.xf_float
  197.  
  198. /* string node */
  199. #define n_str        n_info.n_xstr.xst_str
  200. #define n_strtype    n_info.n_xstr.xst_type
  201.  
  202. /* file pointer node */
  203. #define n_fp        n_info.n_xfptr.xf_fp
  204. #define n_savech    n_info.n_xfptr.xf_savech
  205.  
  206. /* vector/object node */
  207. #define n_vsize        n_info.n_xvect.xv_size
  208. #define n_vdata        n_info.n_xvect.xv_data
  209.  
  210. /* node structure */
  211. typedef struct node {
  212.     char n_type;        /* type of node */
  213.     char n_flags;        /* flag bits */
  214.     union {            /* value */
  215.     struct xsym {        /* symbol node */
  216.         struct node *xsy_plist;    /* symbol plist - (name . plist) */
  217.         struct node *xsy_value;    /* the current value */
  218.     } n_xsym;
  219.     struct xsubr {        /* subr/fsubr node */
  220.         struct node *(*xsu_subr)();    /* pointer to an internal routine */
  221.     } n_xsubr;
  222.     struct xlist {        /* list node (cons) */
  223.         struct node *xl_car;    /* the car pointer */
  224.         struct node *xl_cdr;    /* the cdr pointer */
  225.     } n_xlist;
  226.     struct xint {        /* integer node */
  227.         FIXNUM xi_int;        /* integer value */
  228.     } n_xint;
  229.     struct xfloat {        /* float node */
  230.         FLONUM xf_float;        /* float value */
  231.     } n_xfloat;
  232.     struct xstr {        /* string node */
  233.         int xst_type;        /* string type */
  234.         char *xst_str;        /* string pointer */
  235.     } n_xstr;
  236.     struct xfptr {        /* file pointer node */
  237.         FILE *xf_fp;        /* the file pointer */
  238.         int xf_savech;        /* lookahead character for input files */
  239.     } n_xfptr;
  240.     struct xvect {        /* vector node */
  241.         int xv_size;        /* vector size */
  242.         struct node **xv_data;    /* vector data */
  243.     } n_xvect;
  244.     } n_info;
  245. } NODE;
  246.  
  247. /* execution context flags */
  248. #define CF_GO        1
  249. #define CF_RETURN    2
  250. #define CF_THROW    4
  251. #define CF_ERROR    8
  252. #define CF_CLEANUP    16
  253. #define CF_CONTINUE    32
  254. #define CF_TOPLEVEL    64
  255.  
  256. /* execution context */
  257. typedef struct context {
  258.     int c_flags;            /* context type flags */
  259.     struct node *c_expr;        /* expression (type dependant) */
  260.     jmp_buf c_jmpbuf;            /* longjmp context */
  261.     struct context *c_xlcontext;    /* old value of xlcontext */
  262.     struct node ***c_xlstack;        /* old value of xlstack */
  263.     struct node *c_xlenv;        /* old value of xlenv */
  264.     int c_xltrace;            /* old value of xltrace */
  265. } CONTEXT;
  266.  
  267. /* function table entry structure */
  268. struct fdef {
  269.     char *f_name;            /* function name */
  270.     int f_type;                /* function type SUBR/FSUBR */
  271.     struct node *(*f_fcn)();        /* function code */
  272. };
  273.  
  274. /* memory segment structure definition */
  275. struct segment {
  276.     int sg_size;
  277.     struct segment *sg_next;
  278.     struct node sg_nodes[1];
  279. };
  280.  
  281. /* external procedure declarations */
  282. extern struct node ***xlsave();        /* generate a stack frame */
  283. extern struct node *xleval();        /* evaluate an expression */
  284. extern struct node *xlapply();        /* apply a function to arguments */
  285. extern struct node *xlevlist();        /* evaluate a list of arguments */
  286. extern struct node *xlarg();        /* fetch an argument */
  287. extern struct node *xlevarg();        /* fetch and evaluate an argument */
  288. extern struct node *xlmatch();        /* fetch an typed argument */
  289. extern struct node *xlevmatch();    /* fetch and evaluate a typed arg */
  290. extern struct node *xlgetfile();    /* fetch a file/stream argument */
  291. extern struct node *xlsend();        /* send a message to an object */
  292. extern struct node *xlenter();        /* enter a symbol */
  293. extern struct node *xlsenter();        /* enter a symbol with a static pname */
  294. extern struct node *xlmakesym();    /* make an uninterned symbol */
  295. extern struct node *xlframe();        /* establish a new environment frame */
  296. extern struct node *xlgetvalue();    /* get value of a symbol (checked) */
  297. extern struct node *xlxgetvalue();    /* get value of a symbol */
  298. extern struct node *xlygetvalue();    /* get value of a symbol (no ivars) */
  299.  
  300. extern struct node *cons();        /* (cons x y) */
  301. extern struct node *consa();        /* (cons x nil) */
  302. extern struct node *consd();        /* (cons nil x) */
  303.  
  304. extern struct node *cvsymbol();        /* convert a string to a symbol */
  305. extern struct node *cvcsymbol();    /* (same but constant string) */
  306. extern struct node *cvstring();        /* convert a string */
  307. extern struct node *cvcstring();    /* (same but constant string) */
  308. extern struct node *cvfile();        /* convert a FILE * to a file */
  309. extern struct node *cvsubr();        /* convert a function to a subr/fsubr */
  310. extern struct node *cvfixnum();        /* convert a fixnum */
  311. extern struct node *cvflonum();        /* convert a flonum */
  312.  
  313. extern struct node *newstring();    /* create a new string */
  314. extern struct node *newvector();    /* create a new vector */
  315. extern struct node *newobject();    /* create a new object */
  316.  
  317. extern struct node *xlgetprop();    /* get the value of a property */
  318. extern char *xlsymname();        /* get the print name of a symbol */
  319.  
  320.  
  321.